HPAVC/HPAVC CD-ROM.iso/pc/AMOD095.ZIP/MEMUNIT.PAS

Pascal/Delphi Source File | 1995-11-12 | 8.6 KB | 319 lines

unit memunit;
interface
{$s-}
{$g+}
{$o-}

uses dos,modtypes;
type
   Bit32Struct = LongInt;

   ExtMemMoveStruct =
   Record
      Length       : Bit32Struct;
      SourceHandle : Word;
      SourceOffset : Bit32Struct;
      DestHandle   : Word;
      DestOffset   : Bit32Struct
   End;

const

   isXMS       : Boolean = false;
Var
   XMSResult   : Word;
   XMSError    : Byte;
   XMM_Control : Array[0..1] of Word;
   xmsinfo : record
               buf : pointer;
               bufsize : integer; {size of buf}
               curptn : integer;
               handle : word;
               size : word;  {kbytes}
             end;
   movestruct : extmemmovestruct;

   Function EXISTXMS : Boolean;
   function xmsmaxavail : word;
   Function AllocXMSBlock(malloc : Word) : Word;
   Procedure FreeXMSBlock(handle : Word);
   Procedure MoveXMSBlock(Var MoveStructure : ExtMemMoveStruct);
   function initxms : integer; {0 if ok}
   procedure donexms;

implementation
const
xmssize = 750;

var
patterns : array[0..128] of longint;

{$s-}
Function EXISTXMS : Boolean;
Var
   _al : byte;
   _bx,_es : word;
Begin
   asm
     mov  ax,4300h
     int  2fh
     mov  _al,al
   end;
   If _al = $80 Then
   Begin
      asm
        mov  ax,4310h
        int  2fh
        mov  _bx,bx
        mov  _es,es
      end;
      XMM_Control[0] := _bx;
      XMM_Control[1] := _es;
      EXISTXMS := TRUE
   End
   Else
      EXISTXMS := FALSE
End;

function XMSMaxAvail : word;
(* XMSResult = largest free block of Extended Memory in kilobytes *)
Var
   dx : Word;
Begin
   XMSResult := 1;
   XMSError  := 0;
   Inline
   (  $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
      $B8/$00/$08/                         {  MOV  AX,0800               }
      $55/                                 {  PUSH BP                    }
      $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
      $5D/                                 {  POP  BP                    }
      $89/$96/dx                           {  MOV  dx[BP],DX             }
   );
   XMSResult := dx;
   XMSMaxAvail := dx;
End;

Function AllocXMSBlock(malloc : Word) : Word;
(* If successful, returns handle to Extended Memory Block *)
Var
   ax : Word;
   dx : Word;
   bl : Byte;
Begin
   XMSResult := 1;
   XMSError  := 0;
   Inline
   (  $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
      $8B/$96/malloc/                      {  MOV  DX,malloc[BP]         }
      $B8/$00/$09/                         {  MOV  AX,0900               }
      $55/                                 {  PUSH BP                    }
      $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
      $5D/                                 {  POP  BP                    }
      $89/$86/ax/                          {  MOV  ax[BP],AX             }
      $88/$9E/bl/                          {  MOV  bl[BP],BL             }
      $89/$96/dx                           {  MOV  dx[BP],DX             }
   );
   XMSResult := ax;
   XMSError  := bl;
   AllocXMSBlock := dx
End;

Procedure FreeXMSBlock(handle : Word);
Var
   ax : Word;
   bl : Byte;
Begin
   XMSResult := 1;
   XMSError  := 0;
   Inline
   (  $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
      $8B/$96/handle/                      {  MOV  DX,handle[BP]         }
      $B8/$00/$0A/                         {  MOV  AX,0A00               }
      $55/                                 {  PUSH BP                    }
      $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
      $5D/                                 {  POP  BP                    }
      $89/$86/ax/                          {  MOV  ax[BP],AX             }
      $88/$9E/bl                           {  MOV  bl[BP],BL             }
   );
   XMSResult := ax;
   XMSError  := bl
End;

Procedure MoveXMSBlock(Var MoveStructure : ExtMemMoveStruct);
(* NOTE: This procedure assumes that the ExtMemMove structure is valid *)
(* Changed 10/06/89: Needed to force ES: override for XMM Call         *)
Var
   ax,
   segs,
   ofss : Word;
   bl   : Byte;
Begin
   XMSResult := 1;
   XMSError  := 0;
   segs := Seg(MoveStructure);
   ofss := Ofs(MoveStructure);
   Inline
   (  $1E/                                 {  PUSH DS                    }
      $1E/                                 {  PUSH DS                    }
      $07/                                 {  POP  ES                    }
      $8B/$86/segs/                        {  MOV  AX,segs[BP]           }
      $8E/$D8/                             {  MOV  DS,AX                 }
      $8B/$B6/ofss/                        {  MOV  SI,ofss[BP]           }
      $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
      $B8/$00/$0B/                         {  MOV  AX,0B00               }
      $55/                                 {  PUSH BP                    }
      $26/                                 {  ES:                        }
      $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
      $5D/                                 {  POP  BP                    }
      $1F/                                 {  POP  DS                    }
      $89/$86/ax/                          {  MOV  ax[BP],AX             }
      $88/$9E/bl                           {  MOV  bl[BP],BL             }
   );
   XMSResult := ax;
   XMSError  := bl
End;

{$s-}
{$f+}
procedure xms_virt_alloc(numptn,ptnsize : integer);
var
n : integer;
begin
  for n := 0 to 128 do patterns[n] := -1;
  virt_info.numptn := numptn;
  virt_info.ptnsize := ptnsize;
  virt_info.err_cptn := -1;
  virt_info.err_wptn := -1;
  virt_info.err_nptn := -1;
  xmsinfo.curptn := -1;
end;

procedure xms_virt_free;
var
n : integer;
begin
  for n := 0 to 128 do if patterns[n] <> -1 then begin
    patterns[n] := -1;
  end;
end;

procedure xms_virt_allocptn(ptn : integer);
begin
  patterns[ptn] := longint(ptn)*longint(virt_info.ptnsize);
end;

procedure xms_virt_loadptn(ptn : integer;p : pointer);
begin
  with movestruct do begin
    length := virt_info.ptnsize;
    sourcehandle := 0;
    sourceoffset := longint(p);
    desthandle := xmsinfo.handle;
    destoffset := patterns[ptn];
  end;
  movexmsblock(movestruct);
end;

procedure xms_virt_freeptn(ptn : integer);
begin
  patterns[ptn] := -1;
end;

function xms_virt_getptn(ptn : integer) : pointer;
begin
  xms_virt_getptn := xmsinfo.buf;
end;

procedure xms_virt_warnptn(ptn : integer);
begin
  virt_info.warnedptn := ptn;
  if xmsinfo.curptn <> ptn then begin
    with movestruct do begin
      length := virt_info.ptnsize;
      sourcehandle := xmsinfo.handle;
      sourceoffset := patterns[ptn];
      desthandle := 0;
      destoffset := longint(xmsinfo.buf);
    end;
    movexmsblock(movestruct);
    xmsinfo.curptn := ptn;
  end;
end;

procedure xms_virt_needptn(ptn : integer);
begin
  if ptn <> virt_info.warnedptn then begin
    virt_info.err_cptn := -1;
    virt_info.err_wptn := virt_info.warnedptn;
    virt_info.err_nptn := ptn;
  end;
  if xmsinfo.curptn <> ptn then begin
    with movestruct do begin
      length := virt_info.ptnsize;
      sourcehandle := xmsinfo.handle;
      sourceoffset := patterns[ptn];
      desthandle := 0;
      destoffset := longint(xmsinfo.buf)
      {asm
        mov  ax,word ptr xmsinfo.buf
        mov  word ptr destoffset,ax
        mov  ax,word ptr xmsinfo.buf+2
        mov  word ptr destoffset+2,ax
      end;}
    end;
    movexmsblock(movestruct);
    xmsinfo.curptn := ptn;
  end;
end;

procedure xms_virt_noneedptn(ptn : integer);
begin
end;

{$f-}

function initxms : integer;
var
n : integer;
begin
  fillchar(xmsinfo,sizeof(xmsinfo),0);
  if not existxms then begin
    initxms := 1;
    exit;
  end;
  if xmsmaxavail < xmssize then begin
    initxms := 2;
    exit;
  end;
  fillchar(patterns,sizeof(patterns),byte(-1));
  xmsinfo.handle := allocxmsblock(xmssize);
  if xmsresult <> 1 then begin
    initxms := 3;
    exit;
  end;
  xmsinfo.bufsize :=320*32;
  getmem(xmsinfo.buf,xmsinfo.bufsize);
  virt_alloc := xms_virt_alloc;
  virt_free := xms_virt_free;
  virt_allocptn := xms_virt_allocptn;
  virt_loadptn := xms_virt_loadptn;
  virt_freeptn := xms_virt_freeptn;
  virt_getptn := xms_virt_getptn;
  virt_warnptn := xms_virt_warnptn;
  virt_needptn := xms_virt_needptn;
  virt_noneedptn := xms_virt_noneedptn;

  isxms := true;
  initxms := 0;
end;

procedure donexms;
begin
  freemem(xmsinfo.buf,xmsinfo.bufsize);
  freexmsblock(xmsinfo.handle);
end;

end.